COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00016 00003	 If you say (array foo fixnum a b c)
C00019 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp
		  meter:max-max meter:maxf meter:array-name
		  meter:all-comments meter:local-max meter:real-runtime
		  meter:comment-name meter:fun-names)
	 (flonum meter:real-runtime)
	 (fixnum meter:maxf meter:max-max meter:max)) 

(eval-when (compile eval)
	   (setq meter:meters () meter:maxf -1 meter:fun-names ()
		 meter:all-comments () meter:comments ()))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo")
;;; (m "Foo" 3)
;;; (m "Foo" 3 (foo a b c))
;;; (mn "Foo" foo)
;;; (mn "Foo" foo 3)
;;; (mn "Foo" foo 3 (foo a b c))

;;; (meter-funs
;;;  ((zerop "Zerop")(1- "1-") (* "Times")(PUSH "CONSs" CONS 2))
;;; 		  (defun fact (n)			 ↑   ↑ 
;;; 			 (cond ((zerop n) 1)		optionals
;;; 			       (t (* n (fact (1- n)))))))

;;; THE FIRST FORM MUST BE:
;;;	(METER:BEGIN <name>)
;;; THE LAST FORM MUST BE:
;;;	(METER:END)

(defmacro meter:begin (name)
	  (setq meter:array-name (implode (append (explode name) 
						     '(- a r r a y)))
		meter:comment-name (implode (append (explode name)
						     '(- c o m m e n t))) 
		meter:max-max 0
		meter:maxf -1
		meter:fun-names ()
		meter:all-comments ()
		meter:comments ())
	  `(declare (array* (fixnum ,meter:array-name 3)
			    (notype ,meter:comment-name 2))
		    (*expr meter:start-time meter:end-time)))

(defmacro meter:end ()
	  `(progn 'compile
		  (array ,meter:array-name fixnum ,(1+ meter:maxf) 
			 ,(1+ meter:max-max) 2)
		  (array ,meter:comment-name t ,(1+ meter:maxf)
			 ,(1+ meter:max-max))
		  (do ((i ,meter:maxf (1- i)) 
		       (a (quote ,meter:fun-names) (cdr a))
		       (b (quote ,meter:all-comments) (cdr b)))
		      ((< i 0) ())
		      (store (,meter:comment-name i 0) (car a))
		      (store (,meter:array-name i 0 0) 
			     (cadr (assq (car a) ',meter:meters)))
		      (do ((j 1 (1+ j))
			   (c (reverse (car b)) (cdr c)))
			  ((null c) ())
			  (store (,meter:comment-name i j) (cadr (car c))))) 
		  (meter:init-time1 (maknum (get (quote ,meter:array-name) 'array))
				    ,(1+ meter:max-max) 2)
		  (setq meter:array-name (quote ,meter:array-name)
			meter:maxf ,meter:maxf
			meter:comment-name (quote ,meter:comment-name))))

(defmacro meter-funs (funs . functions)
	  `(meter . ,(mapcar #'(lambda (f) 
				       `(defun ,(cadr f) ,(caddr f)
					       .,(meter:meter-funs funs 
								  (cdddr f))))
			     functions)))

(defmacro meter functions
	  (cond ((and (boundp 'meter:meterp)
		      (not meter:meterp))
		 `(progn 'compile
			 . ,(mapcar #'meter:unprocess functions)))
		(t 
		 (let ((name (cadr (car functions))))
		      (setq meter:maxf (1+ meter:maxf))
		      (setq meter:max 0)
           	      `(progn 'compile
			      ,@(mapcar #'(lambda (f)
						  `(defun
						    ,(cadr f)
						    ,(caddr f)
						    .,(meter:process 
						       meter:array-name 
						       (cdddr f))))
			      functions)
			      ,@(progn
				 (push name meter:fun-names)
				 (push 
				  meter:comments
				  meter:all-comments)
				 (setq meter:comments ())
				 (let ((entry (assq name meter:meters)))
				      (cond (entry (rplaca (cdr entry) meter:max))
					    (t 
					     (push 
					      `(,name ,meter:max)
					      meter:meters))))
				 (setq meter:max-max (max meter:max-max meter:max))
				 ())
			      ',name)))))

(defun meter:meter-funs (l f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     (t (let ((entry (assq (car f) l)))
		     (cond (entry
			    `(mn ,(cadr entry) ,(or (caddr entry)
						    (car entry))
				 ,(or (cadddr entry) 1)
				 ,(meter:meter-funs-nl l f)))
			   ((eq (car f) 'store)
			    `(store ,(cadr f) ,(meter:meter-funs l (caddr f))))
			   ((eq (car f) 'quote) f)
			   (t (mapcar #'(lambda (f)
					 (meter:meter-funs l f))
				      f)))))))

(defun meter:meter-funs-nl (l f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:meter-funs l (caddr f))))
	     ((eq (car f) 'quote) f)
	     (t (mapcar #'(lambda (f)
				  (meter:meter-funs l f))
			f))))

(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f)))))
		    (setq meter:max (1+ meter:max))
		    (push `(() ,(cadr f)
			       ,meter:maxf ,meter:max
			       ,inc)
			  meter:comments)
		    (cond (form
			   `(prog2 (meter:start-time) ,(meter:process a form)
				   (meter:end-time ,meter:maxf ,meter:max ,inc))) 
			  (t `(meter:inc-only ,meter:maxf ,meter:max ,inc)))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assq index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
     		     (args
		      (cond (entry 
			     (cddr entry))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f)
					      ,meter:maxf
					      ,meter:max ,inc)
				     meter:comments)
			       `(,meter:maxf ,meter:max ,inc)))))
		    (cond (form
			   `(prog2 (meter:start-time) ,(meter:process a form)
				   (meter:end-time .,args)))
			  (t `(meter:inc-only .,args)))))
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:process a (caddr f))))
	     ((eq (car f) 'quote) f)
	     (t (mapcar #'(lambda (f) (meter:process a f))
			f))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

(defun meter:report ()
       (declare (flonum total-ops total-time))
       (terpri)
       (princ '|Statistics|)
       (terpri)
       (princ '|= <calls> (<percentage>) [runtime (<percentage>)]|)
       (terpri)
       (let ((d-ar (get meter:array-name 'array))
	     (c-ar (get meter:comment-name 'array)))
	    (do ((i 0 (1+ i)))
		((> i meter:maxf) t)
		(terpri)(terpri)
		(princ '|Meter for: |)
		(princ (arraycall t c-ar i 0))
		(terpri)
		(let ((total-ops 0.0) 
		      (total-time 0.0)
		      (max (arraycall fixnum d-ar i 0 0)))
		     (do ((n 2 (1+ n))
			  (total (arraycall fixnum d-ar i 1 0) 
				 (+ total (arraycall fixnum d-ar i n 0)))
			  (total-run (arraycall fixnum d-ar i 1 1)
				     (+ total-run (arraycall fixnum d-ar i n 1))))
			 ((> n max) (setq total-ops (float total)
					  total-time 
					  (cond ((boundp 'meter:real-runtime) 
						 (*$ 1000.0
						     (float meter:real-runtime)))
						(t (float total-run))))))
		     (do ((n 1 (1+ n)))
			 ((> n max) 
			  (princ '|Total = |)(princ (fix total-ops))
			  (tyo #o9) (princ (//$ total-time 1000.0))
			  (terpri))
			 (princ (arraycall t c-ar i n))
			 (princ '| = |)
			 (let ((x (arraycall fixnum d-ar i n 0))
			       (y (arraycall fixnum d-ar i n 1)))
			      (princ x)
			      (princ '| (|)
			      (princ (//$ 
				      (float 
				       (fix 
					(*$ 10000.0 
					    (+$ .00005
						(//$ (float x)
						     total-ops))))) 
				      100.0))
			      (princ '|%)|)
			      (princ '| |)
			      (princ '|[|)
			      (princ (//$ (float y) 1000.0))
			      (princ '| (|)
			      (princ (//$ 
				      (float 
				       (fix 
					(*$ 10000.0 
					    (+$ .00005
						(//$ (float y)
						     total-time))))) 
				      100.0))
			      (princ '|%)]|))
			 (terpri))))))

(defun meter:init ()
       (let ((ar (get meter:array-name 'array)))
	    (do ((i 0 (1+ i)))
		((> i meter:maxf) t)
		(let ((stop (arraycall fixnum ar i 0 0)))
		     (do ((j 1 (1+ j)))
			 ((> j stop))
			 (store (arraycall fixnum ar i j 0) 0)
			 (store (arraycall fixnum ar i j 1) 0))))))
;;; If you say (array foo fixnum a b c)
;;; (meter:init-time1 (maknum (get 'foo 'array)) b c)

(lap meter:init-time1 subr)
(args meter:init-time1 (nil . 3))
	(move tt inipdl);init stack pointer
	(movem tt pdl)
 	(hrrz a 0 a)	;get address
	(hrrz tt 0 a)
	(hrrzi tt 4 tt)	;business address
	(addi tt 2)
	(movem tt array)
	(move tt 0 c)
	(movem tt factor2)
	(imul tt 0 b)	;multiply it
	(movem tt factor1)
	(movei a 't)
	(popj p)

;;; (meter:start-time)
(entry meter:start-time subr)
(args meter:start-time (nil . 0))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(push fxp tt)
	(exch fxp pdl)
	(movei a 't)
	(popj p)

;;; (meter:end-time <function-number> <meter-number> <increment>)
(entry meter:end-time subr)
(args meter:end-time (nil . 3))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(pop fxp t)
	(exch fxp pdl)
	(sub tt t)
	(move t 0 a)	;get function-number
	(imul t factor1)
	(move r 0 b)	;get meter-number
	(imul r factor2)
	(add t r)	;store the increment in the 0th position
	(add t array)
	(move c 0 c)	
	(addm c 0 t)	;increment
	(addm tt 1 t)	;add the runtime
	(popj p)	;return the function-number

;;; (meter:inc-only <function-number> <meter-number> <increment>)
(entry meter:inc-only subr)
(args meter:inc-only (nil . 3))
	(move t 0 a)	;get function-number
	(imul t factor1)
	(move r 0 b)	;get meter-number
	(imul r factor2)
	(add t r)	;store the increment in the 0th position
	(add t array)
	(move c 0 c)	
	(addm c 0 t)	;increment
	(popj p)	;return the function-number

array (0)
factor1 (0)
factor2 (0)
stack (block 2000)
pdl (776000←22 0 stack)
inipdl (776000←22 0 stack)
()